home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BBS Toolkit
/
BBS Toolkit.iso
/
doors_1
/
fd200.zip
/
AVL_TREE.PAS
next >
Wrap
Pascal/Delphi Source File
|
1988-02-27
|
13KB
|
436 lines
type balance = ( L, B, R );
LINK = ^Branch;
Branch = record
leaf : data;
left : LINK;
right : LINK;
bal : balance;
end;
{ *********** CONSTANTS, AND VARIABLES FOR AV Lists ********** }
const on_bit : array[0..15] of word =
( $0001,$0002,$0004,$0008,$0010,$0020,$0040,$0080,
$0100,$0200,$0400,$0800,$1000,$2000,$4000,$8000 );
off_bit : array[0..15] of word =
( $FFFE,$FFFD,$FFFB,$FFF7,$FFEF,$FFDF,$FFBF,$FF7F,
$FEFF,$FDFF,$FBFF,$F7FF,$EFFF,$DFFF,$BFFF,$7FFF );
depth : integer = -1;
h : integer = 0; { Set by recursive calls to search to
indicate that the tree has grown.
It will magically change its value
everytime ins() is called recursively. }
var Newnode,
Conflicting,
AvlKey,
root,
tbranch,
p : LINK;
Notfound : boolean;
map : array[0..1023] of integer;
n,i : integer;
{ *********** SPECIFIC PROCEDURES AND FUNCTION FOR AV Lists ********** }
function talloc: LINK;
var p : LINK;
begin
New(p);
if p <> NIL then
with p^ do
begin
left := NIL;
right := NIL;
bal := B;
end;
talloc := p;
end;
procedure tfree( var p : LINK);
begin
dispose(p);
end;
function testbit(c: integer): integer;
begin
testbit := Map[ c SHR 4] AND (on_bit[c AND $0F]);
end;
procedure setbit( c, val : integer);
begin
if (val <> 0)
then
Map[c SHR 4] := Map[c SHR 4] OR (on_bit[(c AND $0F)])
else
Map[c SHR 4] := Map[c SHR 4] AND (off_bit[(c AND $0F)]) ;
end;
procedure trav(root : LINK; direction: balance; device : integer);
label trav_exit;
var i : integer;
begin
if (root <> NIL) AND (escape = FALSE) then
begin
depth := depth + 1;
if (root^.left <> NIL)
then trav(root^.left,R, device)
else setbit(depth + 1,1);
if (escape = TRUE) then goto trav_exit;
if device = 0 then print(root^.leaf)
else fprint(root^.leaf);
if direction = L then setbit(depth, 0)
else setbit(depth, 1);
if (root^.right <> NIL)
then trav(root^.right, L, device)
else setbit(depth + 1, 0);
depth := depth - 1;
end;
trav_exit:
end;
procedure tprint(root : LINK);
var i : integer;
begin
escape := FALSE;
for i := 0 to 1023 do map[i] := 0;
depth := -1;
trav( root, R, 0);
end;
function find( root, key : LINK ): LINK;
begin
if ( root = NIL )
then find := NIL
else case cmp( key^.leaf, root^.leaf) of
-1 : find := find(root^.left, key);
0 : find := root;
1 : find := find(root^.right, key);
end;
end;
procedure ins( var pp : LINK );
var p, p1, p2 : LINK;
begin
p := pp;
if ( p = NIL )
then
begin
p := Newnode;
h := 1;
end
else
case cmp(newnode^.leaf, p^.leaf) of
0 : Conflicting := p;
-1 : begin
ins( p^.left );
if ( h > 0 ) then
case p^.bal of
R: begin
p^.bal := B;
h := 0;
end;
B: p^.bal := L;
L: begin
p1 := p^.left;
if ( p1^.bal = L )
then begin
p^.left := p1^.right;
p1^.right := p;
p^.bal := B;
p := p1;
end
else begin
p2 := p1^.right;
p1^.right := p2^.left;
p2^.left := p1;
p^.left := p2^.right;
p2^.right := p;
if (p2^.bal = L)
then p^.bal := R
else p^.bal := B;
if (p2^.bal = R)
then p1^.bal := L
else p1^.bal := B;
p := p2;
end;
p^.bal := B;
h := 0;
end;
end;
end;
1 : begin
ins( p^.right );
if ( h > 0 ) then
case p^.bal of
L: begin
p^.bal := B;
h := 0;
end;
B: p^.bal := R;
R: begin
p1 := p^.right;
if ( p1^.bal = R )
then
begin
p^.right := p1^.left;
p1^.left := p;
p^.bal := B;
p := p1;
end
else
begin
p2 := p1^.left;
p1^.left := p2^.right;
p2^.right := p1;
p^.right := p2^.left;
p2^.left := p;
if (p2^.bal = R)
then p^.bal := L
else p^.bal := B;
if (p2^.bal = L)
then p1^.bal := R
else p1^.bal := B;
p := p2;
end;
p^.bal := B;
h := 0;
end;
end;
end;
end;
pp := p;
end;
procedure insert( var rootp, netbrnch : LINK);
begin
{ Insert newnode into tree pointed to by rootp. Cmp is passed
Return NIL on success or a pointer to the conflicting node
on error.
}
h := 0;
Newnode := netbrnch;
Conflicting := NIL;
ins(rootp);
if Conflicting <> NIL then tfree(netbrnch);
end;
function balance_l( var pp : LINK ): boolean;
{ This routine is called when the left branch of the current
subtree (pointed to by p) has shrunk. It adjusts the balance
factors and rebalances if necessary, modifying *pp to point
at the new root (after the rebalance). Returns TRUE if the
tree got smaller as a result of the delete or the rebalance
operation, else returns 0.
}
var p, p1, p2 : LINK;
b1, b2 : balance;
got_smaller : boolean;
begin
got_smaller := TRUE;
p := pp;
case p^.bal of
L: p^.bal := B;
B: begin
p^.bal := R;
got_smaller := FALSE;
end;
R: begin
p1 := p^.right;
b1 := p1^.bal;
if ( b1 <> L )
then begin
p^.right := p1^.left;
p1^.left := p;
if ( b1 <> B )
then begin
p^.bal := B;
p1^.bal := B;
end
else begin
p^.bal := R;
p1^.bal := L;
got_smaller := FALSE;
end;
p := p1;
end
else begin
p2 := p1^.left;
b2 := p2^.bal;
p1^.left := p2^.right;
p2^.right := p1;
p^.right := p2^.left;
p2^.left := p;
case b2 of
R : p^.bal := L;
B, L : p^.bal := B;
end;
case b2 of
L : p1^.bal := R;
B, R : p1^.bal := B;
end;
p := p2;
p2^.bal := B;
end;
end;
end;
pp := p;
balance_l := got_smaller;
end;
function balance_r( var pp : LINK ): boolean;
{ same as balance_l, but is called when a right subtree has
been made smaller.
}
var p, p1, p2 : LINK;
b1, b2 : balance;
got_smaller : boolean;
begin
got_smaller := TRUE;
p := pp;
case p^.bal of
R: p^.bal := B;
B: begin
p^.bal := L;
got_smaller := FALSE;
end;
L: begin
p1 := p^.left;
b1 := p1^.bal;
if ( b1 <> R )
then begin
p^.left := p1^.right;
p1^.right := p;
if ( b1 <> B )
then p^.bal := B
else begin
p^.bal := L;
p1^.bal := R;
got_smaller := FALSE;
end;
p := p1;
end
else begin
p2 := p1^.right;
b2 := p2^.bal;
p1^.right := p2^.left;
p2^.left := p1;
p^.left := p2^.right;
p2^.right := p;
case b2 of
L : p^.bal := R;
B,R : p^.bal := B;
end;
case b2 of
R : p1^.bal := L;
B,L : p1^.bal := R;
end;
p := p2;
p2^.bal := B;
end;
end;
end;
pp := p;
balance_r := got_smaller;
end;
function descend( var rootp, dpp : LINK): boolean;
{ rootp address of root of current node
dpp address of node to be deleted
Does the actual delete when the root node has both left and
right descendents. Descends to the rightmost node of the left
subtree and then copies the contents of that node to the
node-to-be-deleted (dpp). Then the node-to-be-deleted is
modified to point to the former rightmost node.
}
begin
if ( rootp^.right <> NIL )
then
case descend( rootp^.right, dpp) of
FALSE : descend := FALSE;
TRUE : descend := balance_r(rootp) ;
end
else begin
move(rootp^.leaf,dpp^.leaf,sizeof(data));
dpp := rootp;
rootp := rootp^.left;
descend := TRUE;
end;
end;
function del(var rootp : LINK ): boolean;
{
Delete AvlKey from tree pointed to by rootp. Return TRUE if the size
of the tree has been reduced, FALSE otherwise.
}
var dp : LINK; { pointer to node to delete }
got_smaller : boolean;
begin
got_smaller := FALSE; { set TRUE if tree shrinks }
if ( rootp = NIL )
then Notfound := TRUE
else begin
case cmp(AvlKey^.leaf, rootp^.leaf) of
-1 : if ( del(rootp^.left) = TRUE )
then got_smaller := balance_l( rootp ) ;
1 : if ( del(rootp^.right) = TRUE )
then got_smaller := balance_r( rootp ) ;
0 : begin
case check_if_ok(rootp^.leaf) of
-1 : Notfound := TRUE;
0 : if (del(rootp^.right) = TRUE)
then got_smaller := balance_r(rootp);
1 : begin
dp := rootp;
if ( dp^.right = NIL )
then begin
rootp := dp^.left;
got_smaller := TRUE;
end
else if ( dp^.left = NIL )
then begin
rootp := dp^.right;
got_smaller := TRUE;
end
else if ( descend(rootp^.left, dp ) = TRUE )
then got_smaller := balance_l( rootp ) ;
tfree( dp );
end;
end;
end;
end;
end;
del := got_smaller;
end;
function delete( var rootp, pass : LINK ): boolean;
var dmy : boolean;
{
Cmp is a comparison routine with two leaf records passed to
it. It should return
-1 if key < node;
0 if key = node;
1 if key > node.
DELETE returns 1 if the node was deleted,
0 if the node wasn't in the tree.
}
begin
AvlKey := pass;
Notfound := FALSE;
dmy := del( rootp );
delete := NOT Notfound;
end;
